home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / info / cad08n10.zip / CDNCA-93.LSP next >
Lisp/Scheme  |  1994-02-21  |  9KB  |  271 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;  CADENCE Magazine     Advanced AutoLISP Concepts  Oct/93
  3. ;;;  Bill Kramer   *BBS* 614-792-3386   *CIS* 73717,2635
  4. ;;;  
  5. ;;;  Orthographic projection to 3D
  6. ;;----------------------------------------------------------------
  7. ;;;  Listing 1:  Main function
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. (prompt "\nFOLD:  Ortho to 3D base")
  10. (defun C:FOLD ( / P1 P2            ;;temp points
  11.                   SS_BASE SS_VIEW  ;;selection sets of windows
  12.                   XB1 XB2 YB1 YB2  ;;extrema of base window
  13.                   XF1 XF2 YF1 YF2  ;;extrema of flange window
  14.                   EN1 EN2          ;;shared entity names
  15.                   EL1 EL2)         ;;shared entity lists
  16.   ;;
  17.   (setvar "CMDECHO" 0)
  18.   ;;
  19.   (setq P1 (getpoint "\nLocate corner of window for base view: "))
  20.   (if P1 
  21.    (progn
  22.      (setq P2 (getcorner P1 "  other corner: "))
  23.      (if P2 
  24.         (setq SS_BASE (ssget "W" P1 P2)
  25.               XB1 (min (car P1) (car P2))
  26.               XB2 (max (car P1) (car P2))
  27.               YB1 (min (cadr P1) (cadr P2))
  28.               YB2 (max (cadr P1) (cadr P2))
  29.         )
  30.      )
  31.      (if SS_BASE 
  32.       (progn
  33.         (while 
  34.            (progn
  35.              (setq P3 
  36.                (getpoint "\nLocate corner of window for side part: "))
  37.              (if P3 
  38.                (setq P4 (getcorner P3 "  other corner: ")) 
  39.                (setq P3 nil))
  40.              (if (and P3 P4) 
  41.                 (setq SS_FLNG (ssget "W" P3 P4)
  42.                       XF1 (min (car P3) (car P4))
  43.                       XF2 (max (car P3) (car P4))
  44.                       YF1 (min (cadr P3) (cadr P4))
  45.                       YF2 (max (cadr P3) (cadr P4))
  46.                 )
  47.              )
  48.            ) ;;end PROGN predicate test if window selected
  49.           (while 
  50.               (setq EN1 
  51.                (entsel "\nPick shared entity on BASE: "))
  52.              (setq EN2 (entsel "\nPick shared entity on SIDE: "))
  53.              (if EN2 
  54.                (progn
  55.                  (setq EL1 (entget (car EN1))
  56.                        EL2 (entget (car EN2)))
  57.                  (if (and (= (cdr (assoc 0 EL1)) "LINE")
  58.                           (= (cdr (assoc 0 EL2)) "LINE"))
  59.                    (FOLD_IT)
  60.                    (prompt "\n***Selected objects MUST be lines")
  61.                  )
  62.                )
  63.              )
  64.           ) ;;end inner while loop
  65.         ) ;;end outer while loop
  66.       )
  67.      )
  68.    )
  69.   )
  70.   (prompt "\nFOLD Finished")
  71.   (princ)
  72. )
  73. ;;----------------------------------------------------------------
  74. ;;;  Listing 2:  FOLD_IT Function
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. (defun FOLD_IT ( / P1 P2 P3 P4 A1 A2 SIDE_BASE SIDE_FLNG SS_TMP)
  77.    ;;retrieve the data from the entity lists
  78.    (setq P1 (cdr (assoc 10 EL1))
  79.          P2 (cdr (assoc 11 EL1))
  80.          P3 (cdr (assoc 10 EL2))
  81.          P4 (cdr (assoc 11 EL2))
  82.          A1 (angle P1 P2)
  83.          A2 (angle P3 P4)
  84.    )
  85.    ;;want lines 90 or 180 degrees, swap to correct
  86.    (cond 
  87.      ((equal A1 (* PI 1.5) 0.00001) ;;check for A1=270
  88.         (setq PT P1
  89.               P1 P2
  90.               P2 PT)
  91.      )
  92.      ((or (equal A1 0.0 0.00001) ;;check for A1=0 or 360
  93.           (equal A1 (* 2 PI) 0.00001))
  94.         (setq PT P1
  95.               P1 P2
  96.               P2 PT)
  97.      )
  98.    )
  99.    (cond
  100.      ((equal A2 (* PI 1.5) 0.00001)
  101.         (setq PT P3
  102.               P3 P4
  103.               P4 PT)
  104.      )
  105.      ((or (equal A2 0.0 0.00001)
  106.           (equal A2 (* 2 PI) 0.00001))
  107.         (setq PT P3
  108.               P3 P4
  109.               P4 PT)
  110.      )
  111.    )
  112.    ;;get angles for both lines
  113.    (setq A1 (angle P1 P2) ;;line on base
  114.          A2 (angle P3 P4));;line on flange
  115.    ;;base geometry check
  116.    (if (equal A1 (/ PI 2) 0.000001) ;;equal to 90?
  117.       (setq SIDE_BASE  ;;yes, either left or right side
  118.                (if (> (abs (- (car P1) XB2)) ;;X of P1 closer
  119.                       (abs (- (car P1) XB1)));;to XB1 or XB2?
  120.                                 "L"    ;;left side [XB1]
  121.                                 "R"    ;;else right side [XB2]
  122.                )
  123.       )
  124.       (setq SIDE_BASE ;;else it must be 180
  125.                (if (> (abs (- (cadr P1) YB2)) ;;pick bottom
  126.                       (abs (- (cadr P1) YB1)));;or top
  127.                                 "B"
  128.                                 "T"
  129.                )
  130.       )
  131.    )
  132.    ;;flange geometry check
  133.    (if (equal A2 (/ PI 2) 0.000001)
  134.        (setq SIDE_FLNG
  135.                 (if (> (abs (- (car P3) XF2))
  136.                        (abs (- (car P3) XF1)))
  137.                                 "L"
  138.                                 "R"
  139.                 )
  140.        )
  141.        (setq SIDE_FLNG
  142.                 (if (> (abs (- (cadr P3) YF2))
  143.                        (abs (- (cadr P3) YF1)))
  144.                                 "B"
  145.                                 "T"
  146.                 )
  147.        )
  148.    )
  149.  
  150.    ;;remove shared line from SS_FLNG, no need to copy
  151.    (ssdel (car EN2) SS_FLNG)
  152.  
  153.    (if (equal A1 A2 0.000001) ;;views side by side?
  154.        ;;;yes, mirror and copy or just copy?
  155.        (if (= SIDE_BASE SIDE_FLNG) ;;must mirror objects
  156.            (setq SS_TMP (do_mirror SS_FLNG P3 P4))
  157.            (setq SS_TMP (do_copy SS_FLNG P3 P3))
  158.        )
  159.        ;;else we gotta rotate into position...
  160.        (cond
  161.          ((= SIDE_BASE "R")
  162.              (cond
  163.                ((= SIDE_FLNG "T")
  164.                       (setq SS_TMP (do_copy_rotate SS_FLNG P4 (/ PI 2))
  165.                             P3 P4))
  166.                ((= SIDE_FLNG "B")
  167.                       (setq SS_TMP (do_copy_rotate SS_FLNG P3 (/ PI -2))))
  168.              ))
  169.          ((= SIDE_BASE "L")
  170.              (cond
  171.                ((= SIDE_FLNG "T")
  172.                       (setq SS_TMP (do_copy_rotate SS_FLNG P3 (/ PI -2))))
  173.                ((= SIDE_FLNG "B")
  174.                       (setq SS_TMP (do_copy_rotate SS_FLNG P4 (/ PI 2))
  175.                             P3 P4))
  176.              ))
  177.          ((= SIDE_BASE "T")
  178.              (cond
  179.                ((= SIDE_FLNG "L")
  180.                       (setq SS_TMP (do_copy_rotate SS_FLNG P3 (/ PI 2))))
  181.                ((= SIDE_FLNG "R")
  182.                       (setq SS_TMP (do_copy_rotate SS_FLNG P4 (/ PI -2))
  183.                             P3 P4))
  184.              ))
  185.          ((= SIDE_BASE "B")
  186.              (cond
  187.                ((= SIDE_FLNG "L")
  188.                       (setq SS_TMP (do_copy_rotate SS_FLNG P4 (/ PI -2))
  189.                             P3 P4))
  190.                ((= SIDE_FLNG "R")
  191.                       (setq SS_TMP (do_copy_rotate SS_FLNG P3 (/ PI 2))))
  192.              ))
  193.        ) ;;ends COND
  194.    )
  195.    ;;move copy of flange next to base
  196.    (command "_MOVE" SS_TMP "" P3 P1) 
  197.    ;;rotate copy of flange graphics 90 around axis of base line
  198.    (cond
  199.       ((= SIDE_BASE "R")
  200.           (do_rot_@_Y SS_TMP P1 (/ PI 2)))
  201.       ((= SIDE_BASE "L")
  202.           (do_rot_@_Y SS_TMP P1 (* PI 1.5)))
  203.       ((= SIDE_BASE "T")
  204.           (do_rot_@_X SS_TMP P1 (/ PI 2)))
  205.       ((= SIDE_BASE "B")
  206.           (do_rot_@_X SS_TMP P1 (* PI 1.5)))
  207.    )
  208.    (command "_REDRAW")
  209. )
  210.  
  211. ;;----------------------------------------------------------------
  212. ;;;  Listing 3: DO AutoCAD commands
  213. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  214. (defun DO_MIRROR (SS P1 P2)
  215.   (setq E_MARK (MARK_PLACE))
  216.   (command "_MIRROR" SS "" P1 P2 "N")
  217.   (MARK_SS E_MARK)
  218. )
  219. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
  220. (defun DO_COPY (SS P1 P2)
  221.   (setq E_MARK (MARK_PLACE))
  222.   (command "_COPY" SS "" P1 P2)
  223.   (MARK_SS E_MARK) 
  224. )
  225. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  226. (defun DO_COPY_ROTATE (SS P1 ROT)
  227.   (setq E_MARK (MARK_PLACE))
  228.   (command "_COPY" SS "" P1 P1)
  229.   (setq SS (MARK_SS E_MARK))
  230.   (command "_ROTATE" SS "" P1 (angtos ROT))
  231.   SS
  232. )
  233. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  234. (defun DO_ROT_@_X (SS P1 ROT)
  235.   (setq E_MARK (MARK_PLACE))
  236.   (command "_COPY" SS "" P1 P1)
  237.   (setq SS (MARK_SS E_MARK))
  238.   (command "_UCS" "_Y" 90
  239.            "_ROTATE" SS "" (trans P1 0 1) (angtos ROT)
  240.            "_UCS" "_W")
  241.   SS
  242. )
  243. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  244. (defun DO_ROT_@_Y (SS P1 ROT)
  245.   (setq E_MARK (MARK_PLACE))
  246.   (command "_COPY" SS "" P1 P1)
  247.   (setq SS (MARK_SS E_MARK))
  248.   (command "_UCS" "_X" 90
  249.            "_ROTATE" SS "" (trans P1 0 1) (angtos ROT)
  250.            "_UCS" "_W")
  251.   SS
  252. )
  253. ;;----------------------------------------------------------------
  254. ;;;  Listing 4: Mark place and selection set make
  255. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  256. (defun MARK_PLACE ()
  257.   (command "_POINT" (list 0 0 0))
  258.   (entlast)
  259. )
  260. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  261. (defun MARK_SS (EN / E SS_T)
  262.   (setq E (entnext EN)
  263.         SS_T (ssadd E)
  264.   )
  265.   (while (setq E (entnext E))
  266.     (ssadd E SS_T))
  267.   (entdel EN)
  268.   SS_T
  269. )
  270. (princ)
  271.